shakespeare-i18n (empty) → 0.0.0

raw patch · 4 files changed

+325/−0 lines, 4 filesdep +basedep +bytestringdep +directorysetup-changed

Dependencies added: base, bytestring, directory, parsec, shakespeare, template-haskell, text

Files

LICENSE +25/−0
Setup.lhs +8/−0
Text/Shakespeare/I18N.hs +259/−0
shakespeare-i18n.cabal +33/−0

+ LICENSE view

@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2009, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.lhs view

@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple+> import System.Cmd (system)++> main :: IO ()+> main = defaultMain

+ Text/Shakespeare/I18N.hs view

@@ -0,0 +1,259 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+module Text.Shakespeare.I18N+    ( mkMessage+    , RenderMessage (..)+    , ToMessage (..)+    , SomeMessage (..)+    ) 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))++class ToMessage a where+    toMessage :: a -> Text+instance ToMessage Text where+    toMessage = id+instance ToMessage String where+    toMessage = Data.Text.pack++class RenderMessage master message where+    renderMessage :: master+                  -> [Text] -- ^ languages+                  -> message+                  -> Text++instance RenderMessage master Text where+    renderMessage _ _ = id++type Lang = Text++mkMessage :: String+          -> FilePath+          -> Lang+          -> Q [Dec]+mkMessage dt folder lang = do+    files <- qRunIO $ getDirectoryContents folder+    contents <- qRunIO $ fmap catMaybes $ mapM (loadLang folder) files+    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 dt' = ConT $ mkName dt+    let mname = mkName $ dt ++ "Message"+    c1 <- fmap concat $ mapM (toClauses dt) contents+    c2 <- mapM (sToClause dt) sdef+    c3 <- defClause+    return+        [ DataD [] mname [] (map (toCon dt) sdef) []+        , InstanceD+            []+            (ConT ''RenderMessage `AppT` dt' `AppT` ConT mname)+            [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]+            ]+        ]++toClauses :: String -> (Lang, [Def]) -> Q [Clause]+toClauses dt (lang, defs) =+    mapM go defs+  where+    go def = do+        a <- newName "lang"+        (pat, bod) <- mkBody dt (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 $ "Msg" ++ 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 -> SDef -> Q Clause+sToClause dt sdef = do+    (pat, bod) <- mkBody dt (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 (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 $ lines s+            return $ Just (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

+ shakespeare-i18n.cabal view

@@ -0,0 +1,33 @@+name:            shakespeare-i18n+version:         0.0.0+license:         BSD3+license-file:    LICENSE+author:          Michael Snoyman <michael@snoyman.com>+maintainer:      Michael Snoyman <michael@snoyman.com>+synopsis:        A type-based approach to internationalization.+description:+    This package uses the same approach of type-safe URLs to create translated content. It has a simple syntax for translators, while allowing the ful power of Haskell for applying complex grammar rules.+    .+    This package was spun off from yesod-core, and therefore the Yesod documentation is a good place to start in understanding this package. Please see <http://www.yesodweb.com/book/i18n> for more information.++category:        Web, Yesod+stability:       Stable+cabal-version:   >= 1.8+build-type:      Simple+homepage:        http://www.yesodweb.com/book/i18n++library+    build-depends:   base             >= 4       && < 5+                   , shakespeare      >= 0.10    && < 0.11+                   , template-haskell+                   , text             >= 0.7     && < 0.12+                   , parsec+                   , bytestring+                   , directory++    exposed-modules: Text.Shakespeare.I18N+    ghc-options:     -Wall++source-repository head+  type:     git+  location: git://github.com/yesodweb/hamlet.git