diff --git a/Text/Shakespeare/I18N.hs b/Text/Shakespeare/I18N.hs deleted file mode 100644 --- a/Text/Shakespeare/I18N.hs +++ /dev/null @@ -1,366 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Text.Shakespeare.I18N --- Copyright : 2012 Michael Snoyman , Jeremy Shaw --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : Michael Snoyman --- Stability : experimental --- Portability : portable --- --- This module provides a type-based system for providing translations --- for text strings. --- --- It is similar in purpose to gettext or Java message bundles. --- --- The core idea is to create simple data type where each constructor --- represents a phrase, sentence, paragraph, etc. For example: --- --- > data AppMessages = Hello | Goodbye --- --- The 'RenderMessage' class is used to retrieve the appropriate --- translation for a message value: --- --- > class RenderMessage master message where --- > renderMessage :: master -- ^ type that specifies which set of translations to use --- > -> [Lang] -- ^ acceptable languages in descending order of preference --- > -> message -- ^ message to translate --- > -> Text --- --- Defining the translation type and providing the 'RenderMessage' --- instance in Haskell is not very translator friendly. Instead, --- translations are generally provided in external translations --- files. Then the 'mkMessage' Template Haskell function is used to --- read the external translation files and automatically create the --- translation type and the @RenderMessage@ instance. --- --- A full description of using this module to create translations for @Hamlet@ can be found here: --- --- --- --- A full description of using the module to create translations for @HSP@ can be found here: --- --- --- --- You can also adapt those instructions for use with other systems. -module Text.Shakespeare.I18N - ( mkMessage - , mkMessageFor - , mkMessageVariant - , RenderMessage (..) - , ToMessage (..) - , SomeMessage (..) - , Lang - ) where - -import Language.Haskell.TH.Syntax -import Data.Text (Text, pack, unpack) -import System.Directory -import Data.Maybe (catMaybes) -import Data.List (isSuffixOf, sortBy, foldl') -import qualified Data.ByteString as S -import Data.Text.Encoding (decodeUtf8) -import Data.Char (isSpace, toLower, toUpper) -import Data.Ord (comparing) -import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp) -import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>)) -import Control.Arrow ((***)) -import Data.Monoid (mempty, mappend) -import qualified Data.Text as T -import Data.String (IsString (fromString)) - --- | 'ToMessage' is used to convert the value inside #{ } to 'Text' --- --- The primary purpose of this class is to allow the value in #{ } to --- be a 'String' or 'Text' rather than forcing it to always be 'Text'. -class ToMessage a where - toMessage :: a -> Text -instance ToMessage Text where - toMessage = id -instance ToMessage String where - toMessage = Data.Text.pack - --- | the 'RenderMessage' is used to provide translations for a message types --- --- The 'master' argument exists so that it is possible to provide more --- than one set of translations for a 'message' type. This is useful --- if a library provides a default set of translations, but the user --- of the library wants to provide a different set of translations. -class RenderMessage master message where - renderMessage :: master -- ^ type that specifies which set of translations to use - -> [Lang] -- ^ acceptable languages in descending order of preference - -> message -- ^ message to translate - -> Text - -instance RenderMessage master Text where - renderMessage _ _ = id - --- | an RFC1766 / ISO 639-1 language code (eg, @fr@, @en-GB@, etc). -type Lang = Text - --- |generate translations from translation files --- --- This function will: --- --- 1. look in the supplied subdirectory for files ending in @.msg@ --- --- 2. generate a type based on the constructors found --- --- 3. create a 'RenderMessage' instance --- -mkMessage :: String -- ^ base name to use for translation type - -> FilePath -- ^ subdirectory which contains the translation files - -> Lang -- ^ default translation language - -> Q [Dec] -mkMessage dt folder lang = - mkMessageCommon True "Msg" "Message" dt dt folder lang - - --- | create 'RenderMessage' instance for an existing data-type -mkMessageFor :: String -- ^ master translation data type - -> String -- ^ existing type to add translations for - -> FilePath -- ^ path to translation folder - -> Lang -- ^ default language - -> Q [Dec] -mkMessageFor master dt folder lang = mkMessageCommon False "" "" master dt folder lang - --- | create an additional set of translations for a type created by `mkMessage` -mkMessageVariant :: String -- ^ master translation data type - -> String -- ^ existing type to add translations for - -> FilePath -- ^ path to translation folder - -> Lang -- ^ default language - -> Q [Dec] -mkMessageVariant master dt folder lang = mkMessageCommon False "Msg" "Message" master dt folder lang - --- |used by 'mkMessage' and 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data type -mkMessageCommon :: Bool -- ^ generate a new datatype from the constructors found in the .msg files - -> String -- ^ string to append to constructor names - -> String -- ^ string to append to datatype name - -> String -- ^ base name of master datatype - -> String -- ^ base name of translation datatype - -> FilePath -- ^ path to translation folder - -> Lang -- ^ default lang - -> Q [Dec] -mkMessageCommon genType prefix postfix master dt folder lang = do - files <- qRunIO $ getDirectoryContents folder - (_files', contents) <- qRunIO $ fmap (unzip . catMaybes) $ mapM (loadLang folder) files -#ifdef GHC_7_4 - mapM_ qAddDependentFile _files' -#endif - sdef <- - case lookup lang contents of - Nothing -> error $ "Did not find main language file: " ++ unpack lang - Just def -> toSDefs def - mapM_ (checkDef sdef) $ map snd contents - let mname = mkName $ dt ++ postfix - c1 <- fmap concat $ mapM (toClauses prefix dt) contents - c2 <- mapM (sToClause prefix dt) sdef - c3 <- defClause - return $ - ( if genType - then ((DataD [] mname [] (map (toCon dt) sdef) []) :) - else id) - [ InstanceD - [] - (ConT ''RenderMessage `AppT` (ConT $ mkName master) `AppT` ConT mname) - [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3] - ] - ] - -toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause] -toClauses prefix dt (lang, defs) = - mapM go defs - where - go def = do - a <- newName "lang" - (pat, bod) <- mkBody dt (prefix ++ constr def) (map fst $ vars def) (content def) - guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|] - return $ Clause - [WildP, ConP (mkName ":") [VarP a, WildP], pat] - (GuardedB [(guard, bod)]) - [] - -mkBody :: String -- ^ datatype - -> String -- ^ constructor - -> [String] -- ^ variable names - -> [Content] - -> Q (Pat, Exp) -mkBody dt cs vs ct = do - vp <- mapM go vs - let pat = RecP (mkName cs) (map (varName dt *** VarP) vp) - let ct' = map (fixVars vp) ct - pack' <- [|Data.Text.pack|] - tomsg <- [|toMessage|] - let ct'' = map (toH pack' tomsg) ct' - mapp <- [|mappend|] - let app a b = InfixE (Just a) mapp (Just b) - e <- - case ct'' of - [] -> [|mempty|] - [x] -> return x - (x:xs) -> return $ foldl' app x xs - return (pat, e) - where - toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String) - toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d - go x = do - let y = mkName $ '_' : x - return (x, y) - fixVars vp (Var d) = Var $ fixDeref vp d - fixVars _ (Raw s) = Raw s - fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i - fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b) - fixDeref _ d = d - fixIdent vp i = - case lookup i vp of - Nothing -> i - Just y -> nameBase y - -sToClause :: String -> String -> SDef -> Q Clause -sToClause prefix dt sdef = do - (pat, bod) <- mkBody dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef) - return $ Clause - [WildP, ConP (mkName "[]") [], pat] - (NormalB bod) - [] - -defClause :: Q Clause -defClause = do - a <- newName "sub" - c <- newName "langs" - d <- newName "msg" - rm <- [|renderMessage|] - return $ Clause - [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d] - (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d) - [] - -toCon :: String -> SDef -> Con -toCon dt (SDef c vs _) = - RecC (mkName $ "Msg" ++ c) $ map go vs - where - go (n, t) = (varName dt n, NotStrict, ConT $ mkName t) - -varName :: String -> String -> Name -varName a y = - mkName $ concat [lower a, "Message", upper y] - where - lower (x:xs) = toLower x : xs - lower [] = [] - upper (x:xs) = toUpper x : xs - upper [] = [] - -checkDef :: [SDef] -> [Def] -> Q () -checkDef x y = - go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y) - where - go _ [] = return () - go [] (b:_) = error $ "Extra message constructor: " ++ constr b - go (a:as) (b:bs) - | sconstr a < constr b = go as (b:bs) - | sconstr a > constr b = error $ "Extra message constructor: " ++ constr b - | otherwise = do - go' (svars a) (vars b) - go as bs - go' ((an, at):as) ((bn, mbt):bs) - | an /= bn = error "Mismatched variable names" - | otherwise = - case mbt of - Nothing -> go' as bs - Just bt - | at == bt -> go' as bs - | otherwise -> error "Mismatched variable types" - go' [] [] = return () - go' _ _ = error "Mistmached variable count" - -toSDefs :: [Def] -> Q [SDef] -toSDefs = mapM toSDef - -toSDef :: Def -> Q SDef -toSDef d = do - vars' <- mapM go $ vars d - return $ SDef (constr d) vars' (content d) - where - go (a, Just b) = return (a, b) - go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a) - -data SDef = SDef - { sconstr :: String - , svars :: [(String, String)] - , scontent :: [Content] - } - -data Def = Def - { constr :: String - , vars :: [(String, Maybe String)] - , content :: [Content] - } - -loadLang :: FilePath -> FilePath -> IO (Maybe (FilePath, (Lang, [Def]))) -loadLang folder file = do - let file' = folder ++ '/' : file - e <- doesFileExist file' - if e && ".msg" `isSuffixOf` file - then do - let lang = pack $ reverse $ drop 4 $ reverse file - bs <- S.readFile file' - let s = unpack $ decodeUtf8 bs - defs <- fmap catMaybes $ mapM (parseDef . T.unpack . T.strip . T.pack) $ lines s - return $ Just (file', (lang, defs)) - else return Nothing - -parseDef :: String -> IO (Maybe Def) -parseDef "" = return Nothing -parseDef ('#':_) = return Nothing -parseDef s = - case end of - ':':end' -> do - content' <- fmap compress $ parseContent $ dropWhile isSpace end' - case words begin of - [] -> error $ "Missing constructor: " ++ s - (w:ws) -> return $ Just Def - { constr = w - , vars = map parseVar ws - , content = content' - } - _ -> error $ "Missing colon: " ++ s - where - (begin, end) = break (== ':') s - -data Content = Var Deref | Raw String - -compress :: [Content] -> [Content] -compress [] = [] -compress (Raw a:Raw b:rest) = compress $ Raw (a ++ b) : rest -compress (x:y) = x : compress y - -parseContent :: String -> IO [Content] -parseContent s = - either (error . show) return $ parse go s s - where - go = do - x <- many go' - eof - return x - go' = (Raw `fmap` many1 (noneOf "#")) <|> (fmap (either Raw Var) parseHash) - -parseVar :: String -> (String, Maybe String) -parseVar s = - case break (== '@') s of - (x, '@':y) -> (x, Just y) - _ -> (s, Nothing) - -data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg - -instance IsString (SomeMessage master) where - fromString = SomeMessage . T.pack - -instance RenderMessage master (SomeMessage master) where - renderMessage a b (SomeMessage msg) = renderMessage a b msg diff --git a/shakespeare-i18n.cabal b/shakespeare-i18n.cabal --- a/shakespeare-i18n.cabal +++ b/shakespeare-i18n.cabal @@ -1,10 +1,10 @@ name: shakespeare-i18n -version: 1.0.0.5 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman -synopsis: A type-based approach to internationalization. +synopsis: A type-based approach to internationalization. (deprecated) description: This package uses a compile-time, type-safe approach to create translated content. It has a simple syntax for translators, while allowing the full power of Haskell for applying complex grammar rules. . @@ -15,33 +15,10 @@ cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/shakespearean-templates -extra-source-files: test-messages/*.msg library build-depends: base >= 4 && < 5 - , shakespeare >= 1.0 && < 1.3 - , template-haskell - , text >= 0.7 - , parsec - , bytestring - , directory - - exposed-modules: Text.Shakespeare.I18N - ghc-options: -Wall - if impl(ghc >= 7.4) - cpp-options: -DGHC_7_4 - -test-suite test - hs-source-dirs: test - main-is: Spec.hs - other-modules: Text.Shakespeare.I18NSpec - type: exitcode-stdio-1.0 - - ghc-options: -Wall - build-depends: base - , shakespeare-i18n - , hspec >= 1.4 - , text + , shakespeare >= 2.0 source-repository head type: git diff --git a/test-messages/en.msg b/test-messages/en.msg deleted file mode 100644 --- a/test-messages/en.msg +++ /dev/null @@ -1,29 +0,0 @@ -NotAnAdmin: You must be an administrator to access this page. - -WelcomeHomepage: Welcome to the homepage -SeeArchive: See the archive - -NoEntries: There are no entries in the blog -LoginToPost: Admins can login to post -NewEntry: Post to blog -NewEntryTitle: Title -NewEntryContent: Content - -PleaseCorrectEntry: Your submitted entry had some errors, please correct and try again. -EntryCreated title@Text: Your new blog post, #{title}, has been created - -EntryTitle title@Text: Blog post: #{title} -CommentsHeading: Comments -NoComments: There are no comments -AddCommentHeading: Add a Comment -LoginToComment: You must be logged in to comment -AddCommentButton: Add comment - -CommentName: Your display name -CommentText: Comment -CommentAdded: Your comment has been added -PleaseCorrectComment: Your submitted comment had some errors, please correct and try again. - -HomepageTitle: Yesod Blog Demo -BlogArchiveTitle: Blog Archive - diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Text/Shakespeare/I18NSpec.hs b/test/Text/Shakespeare/I18NSpec.hs deleted file mode 100644 --- a/test/Text/Shakespeare/I18NSpec.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -module Text.Shakespeare.I18NSpec - ( spec - ) where - -import Data.Text (Text) -import Text.Shakespeare.I18N - -spec :: Monad m => m () -spec = return () - -data Test = Test - -mkMessage "Test" "test-messages" "en"