kontrakcja-templates 0.1 → 0.11
raw patch · 10 files changed
+242/−406 lines, 10 filesdep +exceptionsdep +jsondep +monad-controldep −HUnitdep −MissingHdep −bytestringdep ~HStringTemplatedep ~basedep ~containersnew-uploader
Dependencies added: exceptions, json, monad-control, transformers-base
Dependencies removed: HUnit, MissingH, bytestring, hslogger, old-time, parsec, string-templates, syb, test-framework, test-framework-hunit, test-framework-quickcheck2, utf8-string
Dependency ranges changed: HStringTemplate, base, containers, directory, html, mtl, time, transformers
Files
- example.hs +0/−58
- kontrakcja-templates.cabal +35/−46
- src/Text/StringTemplates/Fields.hs +72/−31
- src/Text/StringTemplates/Files.hs +8/−4
- src/Text/StringTemplates/Templates.hs +41/−24
- src/Text/StringTemplates/Templates/Class.hs +22/−0
- src/Text/StringTemplates/TemplatesLoader.hs +33/−33
- src/Text/StringTemplates/TextTemplates.hs +29/−68
- src/Text/StringTemplates/Utils.hs +2/−2
- test/Main.hs +0/−140
− example.hs
@@ -1,58 +0,0 @@-import Text.StringTemplates.Fields-import Text.StringTemplates.TemplatesLoader-import Text.StringTemplates.Templates--import System.Directory-import Control.Monad.Identity-import Text.StringTemplate.Classes---- applicable to renderTemplate, renderTemplateI functions-fields :: Monad m => Fields m ()-fields = do- value "foo" "bar"- valueM "foo2" $ return "bar2"- object "foo3" $ do- value "foo31" "bar31"- value "foo32" "bar32"- objects "foo4" [ do- value "foo411" "bar411"- value "foo412" "bar412"- , do- value "foo421" "bar421"- value "foo422" "bar422"- ]---- applicable to renderTemplateMain functions-params :: [(String, SElem String)]-params = runIdentity $ runFields fields--textTemplates :: String-textTemplates = "\"X\",\"COLUMN1\",\"COLUMN2\"\n"- ++ "\"template1\",\"foo equals $foo$\",\"f==$foo$\"\n"- ++ "\"template2\",\"foo3.foo31=$foo3.foo31$\"\n"--stringTemplates :: String-stringTemplates = "template3=$template1()$ and also $template2()$\n"- ++ "###\n"- ++ "template4=foo bar baz\n"- ++ "foo bar baz\n"--type MyMonad a = TemplatesT Identity a--main :: IO ()-main = do- createDirectoryIfMissing True "/tmp/templates_test"- createDirectoryIfMissing True "/tmp/templates_test/text_templates"- createDirectoryIfMissing True "/tmp/templates_test/string_templates"-- writeFile "/tmp/templates_test/text_templates/test.csv" textTemplates- writeFile "/tmp/templates_test/string_templates/templates.st" stringTemplates-- templates <- readGlobalTemplates "/tmp/templates_test/text_templates" ["/tmp/templates_test/string_templates/templates.st"] ["COLUMN1", "COLUMN2"]-- let x1 = runIdentity $ runTemplatesT ("COLUMN1", templates) $ renderTemplate "template3" fields- putStrLn x1-- let x2 = runIdentity $ runTemplatesT ("COLUMN2", templates) $ renderTemplate "template3" fields -- template2 is taken from COLUMN1 because COLUMN2 doesn't define it- putStrLn x2-
kontrakcja-templates.cabal view
@@ -1,66 +1,55 @@ Name: kontrakcja-templates-Version: 0.1+Version: 0.11 Synopsis:- Utilities for working with many HStringTemplate templates from files+ Utilities for working with many HStringTemplate templates from files. Description:- This library adds support for working with multiple templates in a single file,- and .csv files containing mapping from template names to multiple template versions- (e.g. for translations)+ This library adds support for working with multiple templates in a single+ file, and .json files containing a mapping from template names to multiple+ template versions (e.g. for translations). +Homepage: https://github.com/scrive/kontrakcja-templates License: BSD3 License-file: LICENSE-Author: Scrive-Maintainer: bartek@scrive.com+Author: Scrive AB+Maintainer: Bartek Ćwikłowski <bartek@scrive.com>+Copyright: Scrive AB Build-type: Simple Stability: None Category: Web-Cabal-version: >=1.9-extra-source-files: example.hs+Cabal-version: >=1.10+Tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1 +Source-repository head+ type: git+ location: https://github.com/scrive/kontrakcja-templates.git+ Library exposed-modules: Text.StringTemplates.Fields Text.StringTemplates.Files Text.StringTemplates.Templates+ Text.StringTemplates.Templates.Class Text.StringTemplates.TemplatesLoader Text.StringTemplates.TextTemplates Text.StringTemplates.Utils hs-source-dirs: src- GHC-Options: -Wall -rtsopts- Extensions: FlexibleInstances,- UndecidableInstances,- GeneralizedNewtypeDeriving- build-depends: base >= 4 && < 5,- HStringTemplate == 0.7.0,- containers >= 0.4.2.1 && < 0.5,- utf8-string == 0.3.6,- bytestring >= 0.9.2.1 && < 0.10,- mtl >= 2.0.1.0 && < 2.2,- transformers >= 0.2.2 && < 0.4,- old-time >= 1.1 && < 1.2,- directory >= 1.1.0.2 && < 1.2,- html >= 1.0.1.2 && < 1.1,- MissingH >= 1.1.1.0 && < 1.2,- parsec >= 3.1.1 && < 3.2--Test-Suite test-text-string-templates- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Main.hs- build-depends: base >= 4 && < 5- build-depends: syb >= 0.1- build-depends: MissingH >= 1.0- build-depends: mtl >= 2.0- build-depends: time >= 1.0- build-depends: directory >= 1.0- build-depends: hslogger==1.1.4- build-depends: test-framework >= 0.4.1- build-depends: test-framework-quickcheck2- build-depends: test-framework-hunit- build-depends: HUnit- build-depends: string-templates- build-depends: old-time- build-depends: HStringTemplate == 0.7.0- build-depends: containers >= 0.4.2.1 && < 0.5+ GHC-Options: -Wall+ build-depends: base >= 4.9 && < 5,+ HStringTemplate >= 0.7.0,+ exceptions >= 0.6,+ containers >= 0.4.2.1,+ monad-control >= 0.3.1,+ mtl >= 2.0.1.0,+ transformers-base >= 0.4.1,+ transformers >= 0.2.2,+ time,+ directory >= 1.2,+ html >= 1.0.1.2,+ json >= 0.5 - extensions: FlexibleInstances+ Default-language: Haskell2010+ Default-Extensions: GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ TypeFamilies+ UndecidableInstances+ FlexibleInstances
src/Text/StringTemplates/Fields.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | Module for easy creating template params -- -- Example usage:@@ -19,12 +20,12 @@ -- value \"foo421\" \"bar421\" -- value \"foo422\" \"bar422\" -- ]--- +-- -- \-- applicable to renderTemplateMain functions -- params :: [(String, SElem String)] -- params = runIdentity $ runFields fields -- @-module Text.StringTemplates.Fields ( Fields+module Text.StringTemplates.Fields ( Fields(..) , runFields , value , valueM@@ -32,22 +33,49 @@ , objects ) where -import Control.Applicative+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch import Control.Monad.Reader import Control.Monad.State.Strict-import Text.StringTemplate.Base hiding (ToSElem, toSElem, render)-import Text.StringTemplate.Classes hiding (ToSElem, toSElem)-import qualified Data.ByteString as BS-import qualified Data.ByteString.UTF8 as BS+import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, defaultLiftWith, defaultRestoreT)+import Data.Int+import Data.Word+import Text.StringTemplate.Base hiding (render)+import Text.StringTemplate.Classes import qualified Data.Map as M-import qualified Text.StringTemplate.Classes as HST -import Text.StringTemplates.TemplatesLoader ()+type InnerFields = StateT [(String, SElem String)] -- | Simple monad transformer that collects info about template params-newtype Fields m a = Fields (StateT [(String, SElem String)] m a)- deriving (Applicative, Functor, Monad, MonadTrans)+newtype Fields m a = Fields { unFields :: InnerFields m a }+ deriving (Applicative, Functor, Monad, MonadBase b, MonadTrans, MonadThrow, MonadCatch, MonadMask) +instance MonadBaseControl b m => MonadBaseControl b (Fields m) where+#if MIN_VERSION_monad_control(1,0,0)+ type StM (Fields m) a = ComposeSt Fields m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM+#else+ newtype StM (Fields m) a = StM { unStM :: ComposeSt Fields m a }+ liftBaseWith = defaultLiftBaseWith StM+ restoreM = defaultRestoreM unStM+#endif+ {-# INLINE liftBaseWith #-}+ {-# INLINE restoreM #-}++instance MonadTransControl Fields where+#if MIN_VERSION_monad_control(1,0,0)+ type StT Fields m = StT InnerFields m+ liftWith = defaultLiftWith Fields unFields+ restoreT = defaultRestoreT Fields+#else+ newtype StT Fields m = StT { unStT :: StT InnerFields m }+ liftWith = defaultLiftWith Fields unFields StT+ restoreT = defaultRestoreT Fields unStT+#endif+ {-# INLINE liftWith #-}+ {-# INLINE restoreT #-}+ -- | get all collected template params runFields :: Monad m => Fields m () -> m [(String, SElem String)] runFields (Fields f) = execStateT f []@@ -72,30 +100,43 @@ vals <- mapM (liftM M.fromList . lift . runFields) objs modify ((name, toSElem vals) :) --- | Important Util. We overide default serialisation to support serialisation of bytestrings .--- | We use ByteString with UTF all the time but default is Latin-1 and we get strange chars--- | after rendering. !This will not always work with advanced structures.! So always convert to String.+-- Missing orphan instances of ToSElem we need -class ToSElem a where- toSElem :: (Stringable b) => a -> SElem b+instance ToSElem Int16 where+ toSElem = STR . show -instance (HST.ToSElem a) => ToSElem a where- toSElem = HST.toSElem+instance ToSElem Int32 where+ toSElem = STR . show -instance ToSElem BS.ByteString where- toSElem = HST.toSElem . BS.toString+instance ToSElem Int64 where+ toSElem = STR . show -instance ToSElem (Maybe BS.ByteString) where- toSElem = HST.toSElem . fmap BS.toString+instance ToSElem Word where+ toSElem = STR . show -instance ToSElem [BS.ByteString] where- toSElem = toSElem . fmap BS.toString+instance ToSElem Word8 where+ toSElem = STR . show -instance ToSElem String where- toSElem l = HST.toSElem l+instance ToSElem Word16 where+ toSElem = STR . show -instance (HST.ToSElem a) => ToSElem [a] where- toSElem l = LI $ map HST.toSElem l+instance ToSElem Word32 where+ toSElem = STR . show -instance (HST.ToSElem a) => ToSElem (M.Map String a) where- toSElem m = SM $ M.map HST.toSElem m+instance ToSElem Word64 where+ toSElem = STR . show++-- For some reasons the SElem a is not of class ToSElem+instance Stringable a => ToSElem (SElem a) where+ toSElem (STR a) = (STR a)+ toSElem (BS a) = (BS a)+ toSElem (STSH a) = (STSH a)+ toSElem (SM a) = (SM $ fmap (toSElem) a)+ toSElem (LI a) = (LI $ fmap (toSElem) a)+ toSElem (SBLE a) = (SBLE $ convert a)+ toSElem (SNAT a) = (SNAT $ convert a)+ toSElem (TXT a) = (TXT a)+ toSElem SNull = SNull++convert :: (Stringable a, Stringable b) => a -> b+convert = stFromString . stToString
src/Text/StringTemplates/Files.hs view
@@ -1,17 +1,19 @@ -- |module for reading many template definitions from files module Text.StringTemplates.Files (getTemplates) where -import Data.Char (isAlphaNum)+import Data.Char (isAlphaNum,isControl,isSpace) import Data.List (intercalate, isPrefixOf) import Data.Maybe (maybeToList) import System.IO -- |parses template definitions read from the file path (using utf8) -- definitions are separated by >=1 lines starting with '#'--- if first line of definition looks like foo=bar, then it returns+-- if first line of definition looks like foo=bar or foo=*bar, then it returns -- (foo, bar ++ rest of the lines (from definition) concatenated) -- broken definitons are skipped --+-- Templates created with =* will be cleaned from spaces and eol chars.+-- -- Example template file: -- -- @@@ -48,7 +50,7 @@ -- reads many lines from the handle, stopping at -- first line starting with '#', (read from the handle, not used)--- if line should looks like "foo=bar", then it returns+-- if line should looks like "foo=bar" or "foo=*bar", then it returns -- Just (foo, bar ++ rest of the lines concatenated) -- otherwise Nothing parseTemplate :: Handle -> IO (Maybe (String, String))@@ -58,7 +60,9 @@ if (null ls || null (name) || null t) then return Nothing else do- let template = intercalate "\r\n" ((tail t): (tail ls))+ let template = if ("=*" `isPrefixOf` t)+ then filter (\c -> not (isControl c) && not (isSpace c)) $ concat ((drop 2 t): (tail ls))+ else intercalate "\r\n" ((tail t): (tail ls)) return $ Just (filter isAlphaNum name,template) -- returns list of lines read from the handle
src/Text/StringTemplates/Templates.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Templates.Templates@@ -85,28 +86,16 @@ , renderHelper ) where -import Control.Monad.Trans.Maybe import Text.StringTemplate.Base hiding (ToSElem, toSElem, render)+import Text.StringTemplates.Templates.Class import Text.StringTemplates.TemplatesLoader import Text.StringTemplates.Fields-import Control.Applicative+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch import Control.Monad.Reader import Control.Monad.Identity-import Control.Monad.Error---- | simple reader monad class that provides access to templates-class (Functor m, Monad m) => TemplatesMonad m where- getTemplates :: m Templates -- ^ get templates (for text templates default column name is used)- getTextTemplatesByColumn :: String -> m Templates -- ^ get templates (for text templates specified column name is used)--instance TemplatesMonad m => TemplatesMonad (MaybeT m) where- getTemplates = lift getTemplates- getTextTemplatesByColumn = lift . getTextTemplatesByColumn--instance (TemplatesMonad m , Error e) => TemplatesMonad (ErrorT e m) where- getTemplates = lift getTemplates- getTextTemplatesByColumn = lift . getTextTemplatesByColumn+import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, defaultLiftWith, defaultRestoreT) -- | renders a template by name renderTemplate :: TemplatesMonad m =>@@ -137,19 +126,47 @@ attrs <- runFields fields return $ renderTemplateMain ts name ([]::[(String, String)]) (setManyAttrib attrs) +type InnerTemplatesT = ReaderT (String, GlobalTemplates)+ -- | Simple implementation of TemplatesMonad-newtype TemplatesT m a = TemplatesT { unTT :: ReaderT (String, GlobalTemplates) m a }- deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)+newtype TemplatesT m a = TemplatesT { unTT :: InnerTemplatesT m a }+ deriving (Applicative, Functor, Monad, MonadIO, MonadTrans, MonadBase b, MonadThrow, MonadCatch, MonadMask) runTemplatesT :: (Functor m, Monad m) =>- (String, GlobalTemplates) -- ^ (default column name, global templates)+ (String, GlobalTemplates) -- ^ (default language name, global templates) -> TemplatesT m a -> m a runTemplatesT ts action = runReaderT (unTT action) ts -instance (Functor m, Monad m) => TemplatesMonad (TemplatesT m) where+instance MonadBaseControl b m => MonadBaseControl b (TemplatesT m) where+#if MIN_VERSION_monad_control(1,0,0)+ type StM (TemplatesT m) a = ComposeSt TemplatesT m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM+#else+ newtype StM (TemplatesT m) a = StM { unStM :: ComposeSt TemplatesT m a }+ liftBaseWith = defaultLiftBaseWith StM+ restoreM = defaultRestoreM unStM+#endif+ {-# INLINE liftBaseWith #-}+ {-# INLINE restoreM #-}++instance MonadTransControl TemplatesT where+#if MIN_VERSION_monad_control(1,0,0)+ type StT TemplatesT m = StT InnerTemplatesT m+ liftWith = defaultLiftWith TemplatesT unTT+ restoreT = defaultRestoreT TemplatesT+#else+ newtype StT TemplatesT m = StT { unStT :: StT InnerTemplatesT m }+ liftWith = defaultLiftWith TemplatesT unTT StT+ restoreT = defaultRestoreT TemplatesT unStT+#endif+ {-# INLINE liftWith #-}+ {-# INLINE restoreT #-}++instance (Applicative m, Monad m) => TemplatesMonad (TemplatesT m) where getTemplates = TemplatesT $ do- (column, ts) <- ask- return $ localizedVersion column ts- getTextTemplatesByColumn column = TemplatesT $ do+ (lang, ts) <- ask+ return $ localizedVersion lang ts+ getTextTemplatesByLanguage lang = TemplatesT $ do (_, ts) <- ask- return $ localizedVersion column ts+ return $ localizedVersion lang ts
+ src/Text/StringTemplates/Templates/Class.hs view
@@ -0,0 +1,22 @@+module Text.StringTemplates.Templates.Class where++import Control.Monad.Trans++import Text.StringTemplates.TemplatesLoader++-- | Simple reader monad class that provides access to templates+class (Applicative m, Monad m) => TemplatesMonad m where+ -- | Get templates (for text templates default language name is used).+ getTemplates :: m Templates+ -- | Get templates (for text templates specified language name is used).+ getTextTemplatesByLanguage :: String -> m Templates++-- | Generic, overlappable instance.+instance {-# OVERLAPPABLE #-}+ ( Applicative (t m)+ , Monad (t m)+ , MonadTrans t+ , TemplatesMonad m+ ) => TemplatesMonad (t m) where+ getTemplates = lift getTemplates+ getTextTemplatesByLanguage = lift . getTextTemplatesByLanguage
src/Text/StringTemplates/TemplatesLoader.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Module for reading templates from files module Text.StringTemplates.TemplatesLoader ( Templates , GlobalTemplates@@ -8,14 +7,16 @@ , getTemplatesModTime ) where -import Data.List (isSuffixOf)+import Prelude hiding (fail)+import Data.List (isSuffixOf,find)+import Data.Maybe (fromMaybe) import Text.StringTemplate-import Text.StringTemplate.Classes-import Control.Monad+import Control.Monad hiding (fail)+import Control.Monad.Fail (MonadFail(..)) import Control.Monad.IO.Class import qualified Data.Map as Map import Text.Html (stringToHtmlString)-import System.Time+import Data.Time.Clock import Text.StringTemplates.Files import Text.StringTemplates.TextTemplates import Text.StringTemplates.Utils@@ -23,31 +24,45 @@ -- | Group of string templates type Templates = STGroup String -- | Global map of templates (for a project),--- indexed by a column name (for text string templates, see TextTemplates for doc)+-- indexed by a language name (for text string templates, see TextTemplates for doc) type GlobalTemplates = Map.Map String Templates --- | Retrieve templates for specified column name+-- | Retrieve templates for specified language name localizedVersion :: String -> GlobalTemplates -> Templates-localizedVersion col mtemplates = mtemplates Map.! col+localizedVersion col mtemplates = fromMaybe (error $ "localizedVersion: undefined language: " ++ show col) $ Map.lookup col mtemplates -- Fixme: Make this do only one read of all files !! -- | Reads text templates and templates from files (see TextTemplates and Files modules docs respectively).--- List of text columns is used to load text templates for every column (the rest of them are--- used as fallback columns)-readGlobalTemplates :: MonadIO m =>- FilePath -- ^ dir path to recursively scan for .csv files containing text templates- -> FilePath -- ^ dir path to recursively scan for .st files containing string templates+readGlobalTemplates :: (MonadIO m, MonadFail m) =>+ FilePath -- ^ dir path to recursively scan for .json files containing text templates+ -> FilePath -- ^ dir path to recursively scan for .st files containing string templates+ -> String -- ^ default language. We can guarantee that empty language texts will be replaced -> m GlobalTemplates-readGlobalTemplates textTemplatesFilePath templatesDirPath = do+readGlobalTemplates textTemplatesFilePath templatesDirPath defaultLang = do files <- liftIO $ directoryFilesRecursive templatesDirPath let templatesFilePaths = filter (".st" `isSuffixOf`) files ts <- liftIO $ mapM getTemplates templatesFilePaths tts <- liftIO $ getTextTemplates textTemplatesFilePath- liftM Map.fromList $ forM (Map.keys tts) $ \col -> do- checked <- mapM newCheckedTemplate $ (concat ts) ++ (tts Map.! col)+ let defaultLangTemplates = case (find (\l -> defaultLang == fst l) $ Map.toList tts) of+ Just (_,t) -> t+ Nothing -> error $ "Default language " ++ defaultLang ++ " is not defined."+ liftM Map.fromList $ forM (Map.toList tts) $ \(col,t) -> do+ let t' = fixTT t defaultLangTemplates+ checked <- mapM newCheckedTemplate $ (concat ts) ++ t' return ((col, groupStringTemplates checked)::(String, Templates)) -newCheckedTemplate :: Monad m => (String, String) -> m (String, StringTemplate String)+-- All empty templates will be replaced by values from default lang.+-- Missing templates from defaul lang will be added+fixTT:: [(String, String)] -> [(String, String)] -> [(String, String)]+fixTT [] d = d+fixTT ((n,""):r) d = case find (\x -> n == fst x) d of+ Just t -> t : fixTT r (filter (\x -> n /= fst x) d)+ Nothing -> (n,"") : fixTT r d+fixTT ((n,v):r) d = (n,v) : fixTT r (filter (\x -> n /= fst x) d)++++newCheckedTemplate :: (Monad m, MonadFail m) => (String, String) -> m (String, StringTemplate String) newCheckedTemplate (n,v) = do let t = newSTMP v (errors, _, _) = checkTemplate t@@ -57,7 +72,7 @@ -- | Returns the latest modification time across all template files getTemplatesModTime :: FilePath -- ^ path to dir containing .csv files with template files -> FilePath -- ^ dir path to recursively scan for .st files containing string templates- -> IO ClockTime+ -> IO UTCTime getTemplatesModTime textTemplatesDir templatesDirPath = do mt1 <- getRecursiveMTime templatesDirPath mt2 <- getRecursiveMTime textTemplatesDir@@ -79,18 +94,3 @@ ts' = setEncoderGroup stringToHtmlString ts noescape = groupStringTemplates [("noescape", newSTMP "$it$" :: StringTemplate String)] mt = getStringTemplate name $ mergeSTGroups noescape ts'--{- For some reasons the SElem a is not of class ToSElem -}-instance (Stringable a) => ToSElem (SElem a) where- toSElem (STR a) = (STR a)- toSElem (BS a) = (BS a)- toSElem (STSH a) = (STSH a)- toSElem (SM a) = (SM $ fmap (toSElem) a)- toSElem (LI a) = (LI $ fmap (toSElem) a)- toSElem (SBLE a) = (SBLE $ convert a)- toSElem (SNAT a) = (SNAT $ convert a)- toSElem (TXT a) = (STR $ convert a)- toSElem SNull = SNull--convert :: (Stringable a, Stringable b) => a -> b-convert = stFromString . stToString
src/Text/StringTemplates/TextTemplates.hs view
@@ -2,77 +2,38 @@ -- may be used for reading of csv containing translation templates module Text.StringTemplates.TextTemplates (getTextTemplates) where -import Data.Char (isSpace, isControl)-import Data.List (isSuffixOf)-import System.IO-import Data.Map (Map) import qualified Data.Map as M--import Text.ParserCombinators.Parsec (parse)-import Data.CSV (csvFile)--import Text.StringTemplates.Utils--type Schema = [String]+import Text.JSON+import System.Directory+import Data.List+import Data.Maybe+import Control.Monad --- | Searches recursively a directory for .csv files and--- parses them with the following format:------ @--- \"WHATEVER\", \"column_name1\", \"column_name2\", ...--- \"name\", \"value1\", \"value2\", ...--- \"name2\", \"value3\", \"value4\", ...--- ...--- @------ and returns a list of (name, value) pairs for the chosen column_name--- (across all files) (e.g. for \"column_name1\" from example,--- it would return [(\"name\", \"value1\"), (\"name2\", \"value3\")])--- if the value is missing for column_name (but it's present in other columns),--- tries values from other columns (in order)-getTextTemplates :: FilePath -- ^ path of a directory to search for .csv files- -> IO (Map String [(String, String)])+--- | Searches recursively give directory for translations+--- path/lang_code/*.json will match.+getTextTemplates :: FilePath -- ^ path of a directory to search for .json files+ -> IO (M.Map String [(String, String)]) getTextTemplates path = do- paths <- directoryFilesRecursive path- M.unionsWith (++) `fmap` mapM getTextTemplatesFromFile paths+ dirs <- getDirectoryContents path+ list <- forM dirs $ \d -> do+ isDir <- doesDirectoryExist $ path ++ "/" ++ d+ if (not isDir || "." `isSuffixOf` d)+ then return $ Nothing+ else do+ entries <- filter (\s -> ".json" `isSuffixOf` s) <$> getDirectoryContents (path ++ "/" ++ d)+ translations <- forM entries (\e -> readTranslationFile $ path ++ "/" ++ d ++ "/" ++ e)+ return $ Just (d,concat translations)+ return $ M.fromList $ map fromJust $ filter isJust list --- Parses a .csv file with the following format:--- (line1): WHATEVER, column_name1, column_name2, ...--- (lineN): name, value1, value2, ...--- and returns a map from column name to a list of (name, value) pairs-getTextTemplatesFromFile :: FilePath -> IO (Map String [(String, String)])-getTextTemplatesFromFile path | not $ ".csv" `isSuffixOf` path = return $ M.empty- | otherwise = do- csv <- basicCSVParser path- case csv of- [] -> error $ "CSV parsing error in" ++ path ++ "\nEmpty file"- schemaRow:rows ->- case schemaRow of- [] -> error $ "CSV parsing error in" ++ path ++ "\nEmpty schema/first line"- _:schema -> return $ parseTextTemplates schema rows --- Takes a schema (list of column names) and a list of rows--- (row looks like: [name, value1, value2...]--- and returns a map from column name to a list of (name, value) pairs-parseTextTemplates :: Schema -> [[String]] -> Map String [(String, String)]-parseTextTemplates schema = M.unionsWith (++) . map aux- where aux :: [String] -> Map String [(String, String)]- aux [] = error "parseTextTemplates: row cannot be empty"- aux (name:fields) =- M.fromList $ zip schema $ map makeList $ filter goodField $- zip (repeat name) $ map fixField fields- fixField = replace '\n' ' '- goodField (_, f) = any notSpaceOrControl f || (length f >= 6)- notSpaceOrControl c = not $ isSpace c || isControl c- replace a b = map $ \x -> if x == a then b else x- makeList x = [x]+readTranslationFile :: String -> IO [(String,String)]+readTranslationFile file = do+ mjson <- readFile $ file+ case decode mjson of+ Ok js -> return $ sort $ textsFromJSON $ js+ e -> error $ "Can't parse json with message " ++ show e ++ " for json" ++ mjson --- Parses csv from filepath (using utf-8)-basicCSVParser :: FilePath -> IO [[String]]-basicCSVParser path =- withFile path ReadMode $ \h -> do- hSetEncoding h utf8- content <- hGetContents h- case parse csvFile path content of- Right csv -> return csv- Left s -> error $ "CSV parse error in " ++ path ++ ": " ++ show s++textsFromJSON :: JSValue -> [(String,String)]+textsFromJSON (JSObject jso) = map (\(a,JSString js) -> (a, fromJSString js)) (fromJSObject jso)+textsFromJSON _ = error "While decoding JSON with translations"
src/Text/StringTemplates/Utils.hs view
@@ -6,7 +6,7 @@ import System.Directory import Data.List (isSuffixOf)-import System.Time (ClockTime)+import Data.Time.Clock (UTCTime) directoryEntriesRecursive :: FilePath -- ^ dir path to be searched for recursively -> IO ([FilePath], [FilePath]) -- ^ (list of all subdirs, list of all files)@@ -28,7 +28,7 @@ directoryFilesRecursive path = snd `fmap` directoryEntriesRecursive path -- | Check recursively time of modification of any file(or dir) in directory-getRecursiveMTime :: FilePath -> IO ClockTime+getRecursiveMTime :: FilePath -> IO UTCTime getRecursiveMTime path = do (dirs, files) <- directoryEntriesRecursive path mtimes <- mapM getModificationTime $ dirs ++ files
− test/Main.hs
@@ -1,140 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-import System.IO.HVFS.Utils-import Data.List-import Control.Monad-import Control.Monad.Identity--import Test.Framework as TF (defaultMain, testGroup, Test)-import Test.Framework.Providers.HUnit-import Test.HUnit-import Test.Framework.Providers.QuickCheck2 (testProperty)--import Control.Exception-import System.IO.HVFS.Utils-import Control.Monad-import Data.Either-import Data.Either.Utils-import Data.Functor-import System.Directory-import Data.List-import qualified Data.Map as Map--import Text.StringTemplates.Files-import Text.StringTemplates.TextTemplates-import Text.StringTemplates.Fields-import Text.StringTemplates.TemplatesLoader-import Text.StringTemplates.Templates hiding (getTemplates)-import Text.StringTemplate.Classes (SElem(..), STShow(..))--main :: IO ()-main = defaultMain tests--tests :: [TF.Test]-tests = [ testGroup "Test order" [ testCase "getTextTemplatesFor" test_getTemplates- , testCase "getTextTemplatesFor" test_getTextTemplatesFor- , testCase "test fields" test_fields- , testCase "readGlobalTemplates" test_readGlobalTemplates- ]- ]--textTemplates :: String-textTemplates = "\"X\",\"COLUMN1\",\"COLUMN2\"\n"- ++ "\"template1\",\"foo equals $foo$\",\"f==$foo$\"\n"- ++ "\"template2\",\"foo3.foo31=$foo3.foo31$\"\n"--stringTemplates :: String-stringTemplates = "template3=$template1()$ and also $template2()$\n"- ++ "###\n"- ++ "template4=foo bar baz\n"- ++ "foo bar baz\n"--fields :: Monad m => Fields m ()-fields = do- value "foo" "bar"- valueM "foo2" $ return "bar2"- object "foo3" $ do- value "foo31" "bar31"- value "foo32" "bar32"- objects "foo4" [ do- value "foo411" "bar411"- value "foo412" "bar412"- , do- value "foo421" "bar421"- value "foo422" "bar422"- ]--deriving instance Eq (SElem String)-deriving instance Show (SElem String)-deriving instance Show STShow-instance Eq STShow where- (==) = undefined--setUp :: IO ()-setUp = do- createDirectoryIfMissing True "/tmp/templates_test"- createDirectoryIfMissing True "/tmp/templates_test/text_templates"- createDirectoryIfMissing True "/tmp/templates_test/string_templates"-- writeFile "/tmp/templates_test/text_templates/test.csv" textTemplates- writeFile "/tmp/templates_test/string_templates/templates.st" stringTemplates--tearDown :: IO ()-tearDown = do- removeDirectoryRecursive "/tmp/templates_test"--mktest assertion = bracket setUp (const tearDown) (const assertion)--test_getTemplates :: Assertion-test_getTemplates = mktest $ do- ts <- getTemplates "/tmp/templates_test/string_templates/templates.st"- assertEqual "getTemplates" ts- [ ("template3", "$template1()$ and also $template2()$")- , ("template4", "foo bar baz\r\nfoo bar baz")- ]--test_getTextTemplatesFor :: Assertion-test_getTextTemplatesFor = mktest $ do- ts1 <- getTextTemplatesFor "/tmp/templates_test/text_templates" "COLUMN1" ["COLUMN2"]- assertEqual "getTextTemplatesFor1" ts1- [ ("template1", "foo equals $foo$")- , ("template2", "foo3.foo31=$foo3.foo31$")- ]- ts2 <- getTextTemplatesFor "/tmp/templates_test/text_templates" "COLUMN2" []- assertEqual "getTextTemplatesFor2" ts2 [("template1", "f==$foo$")]- ts3 <- getTextTemplatesFor "/tmp/templates_test/text_templates" "COLUMN2" ["COLUMN1"]- assertEqual "getTextTemplatesFor3" ts3- [ ("template1", "f==$foo$")- , ("template2", "foo3.foo31=$foo3.foo31$")- ]--test_fields :: Assertion-test_fields = do- let fs = runIdentity $ runFields fields- assertEqual "test fields" (Map.fromList fs) $ Map.fromList- [ ("foo", STR "bar")- , ("foo2", STR "bar2")- , ("foo3", SM $ Map.fromList [ ("foo31", STR "bar31")- , ("foo32", STR "bar32")- ])- , ("foo4", LI [ SM $ Map.fromList [ ("foo411", STR "bar411")- , ("foo412", STR "bar412")- ]- , SM $ Map.fromList [ ("foo421", STR "bar421")- , ("foo422", STR "bar422")- ]- ])- ]--test_readGlobalTemplates :: Assertion-test_readGlobalTemplates = mktest $ do- ts <- readGlobalTemplates "/tmp/templates_test/text_templates" ["/tmp/templates_test/string_templates/templates.st"] ["COLUMN1", "COLUMN2"]- let render col name = runIdentity $ runTemplatesT ("COLUMN" ++ show col, ts) $ renderTemplate name fields- assertEqual "templates1" "foo equals bar" $ render 1 "template1"- assertEqual "templates2" "foo3.foo31=bar31" $ render 1 "template2"- assertEqual "templates3" "foo equals bar and also foo3.foo31=bar31" $ render 1 "template3"- assertEqual "templates4" "foo bar baz\r\nfoo bar baz" $ render 1 "template4"-- assertEqual "templates5" "f==bar" $ render 2 "template1"- assertEqual "templates6" "foo3.foo31=bar31" $ render 2 "template2"- assertEqual "templates7" "f==bar and also foo3.foo31=bar31" $ render 2 "template3"- assertEqual "templates8" "foo bar baz\r\nfoo bar baz" $ render 2 "template4"