cli/Hcompta/CLI/Lib/Shakespeare/Leijen.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE ExistentialQuantification #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# LANGUAGE TypeSynonymInstances #-}
   8
   9 -----------------------------------------------------------------------------
  10 -- |
  11 -- Module      :  Text.Shakespeare.I18N
  12 -- Copyright   :  2012 Michael Snoyman <michael@snoyman.com>, Jeremy Shaw
  13 -- License     :  BSD-style (see the LICENSE file in the distribution)
  14 --
  15 -- Maintainer  :  Michael Snoyman <michael@snoyman.com>
  16 -- Stability   :  experimental
  17 -- Portability :  portable
  18 --
  19 -- This module provides a type-based system for providing translations
  20 -- for text strings.
  21 --
  22 -- It is similar in purpose to gettext or Java message bundles.
  23 --
  24 -- The core idea is to create simple data type where each constructor
  25 -- represents a phrase, sentence, paragraph, etc. For example:
  26 --
  27 -- > data AppMessages = Hello | Goodbye
  28 --
  29 -- The 'RenderMessage' class is used to retrieve the appropriate
  30 -- translation for a message value:
  31 --
  32 -- > class RenderMessage master message where
  33 -- >   renderMessage :: master  -- ^ type that specifies which set of translations to use
  34 -- >                 -> [Lang]  -- ^ acceptable languages in descending order of preference
  35 -- >                 -> message -- ^ message to translate
  36 -- >                 -> Text
  37 --
  38 -- Defining the translation type and providing the 'RenderMessage'
  39 -- instance in Haskell is not very translator friendly. Instead,
  40 -- translations are generally provided in external translations
  41 -- files. Then the 'mkMessage' Template Haskell function is used to
  42 -- read the external translation files and automatically create the
  43 -- translation type and the @RenderMessage@ instance.
  44 --
  45 -- A full description of using this module to create translations for @Hamlet@ can be found here:
  46 --
  47 --  <http://www.yesodweb.com/book/internationalization>
  48 --
  49 -- A full description of using the module to create translations for @HSP@ can be found here:
  50 --
  51 --  <http://happstack.com/docs/crashcourse/Templates.html#hsp-i18n>
  52 --
  53 -- You can also adapt those instructions for use with other systems.
  54 module Hcompta.CLI.Lib.Shakespeare.Leijen
  55     ( mkMessage
  56     , mkMessageFor
  57     , mkMessageVariant
  58     , RenderMessage (..)
  59     , ToMessage (..)
  60     , SomeMessage (..)
  61     , Lang
  62     ) where
  63
  64 import Language.Haskell.TH.Syntax
  65 import Control.Applicative ((<$>))
  66 import Control.Monad (filterM, forM)
  67 import Data.Text (Text, pack, unpack)
  68 import System.Directory
  69 import Data.Maybe (catMaybes)
  70 import Data.List (isSuffixOf, sortBy, foldl')
  71 import qualified Data.Map as Map
  72 import qualified Data.ByteString as S
  73 import Data.Text.Encoding (decodeUtf8)
  74 import Data.Char (isSpace, toLower, toUpper)
  75 import Data.Ord (comparing)
  76 import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp)
  77 import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))
  78 import Control.Arrow ((***))
  79 import Data.Monoid (mempty, mappend)
  80 import qualified Data.Text as T
  81 import Data.String (IsString (fromString))
  82
  83 import qualified Hcompta.Lib.Leijen as W
  84
  85 -- | 'ToMessage' is used to convert the value inside #{ } to 'Text'
  86 --
  87 -- The primary purpose of this class is to allow the value in #{ } to
  88 -- be a 'String' or 'Text' rather than forcing it to always be 'Text'.
  89 class ToMessage a where
  90     toMessage :: a -> W.Doc
  91 instance ToMessage W.Doc where
  92     toMessage = id
  93 instance ToMessage Text where
  94     toMessage = W.strict_text
  95 instance ToMessage String where
  96     toMessage = W.strict_text . Data.Text.pack
  97 instance ToMessage Int where
  98     toMessage = W.int
  99 instance ToMessage Integer where
 100     toMessage = W.integer
 101
 102 -- | the 'RenderMessage' is used to provide translations for a message types
 103 --
 104 -- The 'master' argument exists so that it is possible to provide more
 105 -- than one set of translations for a 'message' type. This is useful
 106 -- if a library provides a default set of translations, but the user
 107 -- of the library wants to provide a different set of translations.
 108 class RenderMessage master message where
 109     renderMessage :: master  -- ^ type that specifies which set of translations to use
 110                   -> [Lang]  -- ^ acceptable languages in descending order of preference
 111                   -> message -- ^ message to translate
 112                   -> W.Doc
 113
 114 instance RenderMessage master W.Doc where
 115     renderMessage _ _ = id
 116 instance RenderMessage master Text where
 117     renderMessage _ _ = W.strict_text
 118
 119 -- | an RFC1766 / ISO 639-1 language code (eg, @fr@, @en-GB@, etc).
 120 type Lang = Text
 121
 122 message_prefix :: String
 123 message_prefix = "I18N_"
 124
 125 -- |generate translations from translation files
 126 --
 127 -- This function will:
 128 --
 129 --  1. look in the supplied subdirectory for files ending in @.msg@
 130 --
 131 --  2. generate a type based on the constructors found
 132 --
 133 --  3. create a 'RenderMessage' instance
 134 --
 135 mkMessage :: String   -- ^ base name to use for translation type
 136           -> FilePath -- ^ subdirectory which contains the translation files
 137           -> Lang     -- ^ default translation language
 138           -> Q [Dec]
 139 mkMessage dt folder lang =
 140     mkMessageCommon True message_prefix "Message" dt dt folder lang
 141
 142
 143 -- | create 'RenderMessage' instance for an existing data-type
 144 mkMessageFor :: String     -- ^ master translation data type
 145              -> String     -- ^ existing type to add translations for
 146              -> FilePath   -- ^ path to translation folder
 147              -> Lang       -- ^ default language
 148              -> Q [Dec]
 149 mkMessageFor master dt folder lang = mkMessageCommon False "" "" master dt folder lang
 150
 151 -- | create an additional set of translations for a type created by `mkMessage`
 152 mkMessageVariant :: String     -- ^ master translation data type
 153                  -> String     -- ^ existing type to add translations for
 154                  -> FilePath   -- ^ path to translation folder
 155                  -> Lang       -- ^ default language
 156                  -> Q [Dec]
 157 mkMessageVariant master dt folder lang = mkMessageCommon False message_prefix "Message" master dt folder lang
 158
 159 -- |used by 'mkMessage' and 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data type
 160 mkMessageCommon :: Bool      -- ^ generate a new datatype from the constructors found in the .msg files
 161                 -> String    -- ^ string to append to constructor names
 162                 -> String    -- ^ string to append to datatype name
 163                 -> String    -- ^ base name of master datatype
 164                 -> String    -- ^ base name of translation datatype
 165                 -> FilePath  -- ^ path to translation folder
 166                 -> Lang      -- ^ default lang
 167                 -> Q [Dec]
 168 mkMessageCommon genType prefix postfix master dt folder lang = do
 169     files <- qRunIO $ getDirectoryContents folder
 170     let files' = filter (`notElem` [".", ".."]) files
 171     (_files', contents) <- qRunIO $ fmap (unzip . catMaybes) $ mapM (loadLang folder) files'
 172 #ifdef GHC_7_4
 173     mapM_ qAddDependentFile $ concat _files'
 174 #endif
 175     let contents' = Map.toList $ Map.fromListWith (++) contents
 176     sdef <-
 177         case lookup lang contents' of
 178             Nothing -> error $ "Did not find main language file: " ++ unpack lang
 179             Just def -> toSDefs def
 180     mapM_ (checkDef sdef) $ map snd contents'
 181     let mname = mkName $ dt ++ postfix
 182     c1 <- fmap concat $ mapM (toClauses prefix dt) contents'
 183     c2 <- mapM (sToClause prefix dt) sdef
 184     c3 <- defClause
 185     return $
 186      ( if genType
 187        then ((DataD [] mname [] (map (toCon dt) sdef) []) :)
 188        else id)
 189         [ InstanceD
 190             []
 191             (ConT ''RenderMessage `AppT` (ConT $ mkName master) `AppT` ConT mname)
 192             [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]
 193             ]
 194         ]
 195
 196 toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause]
 197 toClauses prefix dt (lang, defs) =
 198     mapM go defs
 199   where
 200     go def = do
 201         a <- newName "lang"
 202         (pat, bod) <- mkBody dt (prefix ++ constr def) (map fst $ vars def) (content def)
 203         guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]
 204         return $ Clause
 205             [WildP, ConP (mkName ":") [VarP a, WildP], pat]
 206             (GuardedB [(guard, bod)])
 207             []
 208
 209 mkBody :: String -- ^ datatype
 210        -> String -- ^ constructor
 211        -> [String] -- ^ variable names
 212        -> [Content]
 213        -> Q (Pat, Exp)
 214 mkBody dt cs vs ct = do
 215     vp <- mapM go vs
 216     let pat = RecP (mkName cs) (map (varName dt *** VarP) vp)
 217     let ct' = map (fixVars vp) ct
 218     pack' <- [|W.strict_text . Data.Text.pack|]
 219     tomsg <- [|toMessage|]
 220     let ct'' = map (toH pack' tomsg) ct'
 221     mapp <- [|mappend|]
 222     let app a b = InfixE (Just a) mapp (Just b)
 223     e <-
 224         case ct'' of
 225             [] -> [|mempty|]
 226             [x] -> return x
 227             (x:xs) -> return $ foldl' app x xs
 228     return (pat, e)
 229   where
 230     toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String)
 231     toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d
 232     go x = do
 233         let y = mkName $ '_' : x
 234         return (x, y)
 235     fixVars vp (Var d) = Var $ fixDeref vp d
 236     fixVars _ (Raw s) = Raw s
 237     fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i
 238     fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b)
 239     fixDeref _ d = d
 240     fixIdent vp i =
 241         case lookup i vp of
 242             Nothing -> i
 243             Just y -> nameBase y
 244
 245 sToClause :: String -> String -> SDef -> Q Clause
 246 sToClause prefix dt sdef = do
 247     (pat, bod) <- mkBody dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef)
 248     return $ Clause
 249         [WildP, ConP (mkName "[]") [], pat]
 250         (NormalB bod)
 251         []
 252
 253 defClause :: Q Clause
 254 defClause = do
 255     a <- newName "sub"
 256     c <- newName "langs"
 257     d <- newName "msg"
 258     rm <- [|renderMessage|]
 259     return $ Clause
 260         [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]
 261         (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d)
 262         []
 263
 264 toCon :: String -> SDef -> Con
 265 toCon dt (SDef c vs _) =
 266     RecC (mkName $ message_prefix ++ c) $ map go vs
 267   where
 268     go (n, t) = (varName dt n, NotStrict, ConT $ mkName t)
 269
 270 varName :: String -> String -> Name
 271 varName a y =
 272     mkName $ concat [lower a, "Message", upper y]
 273   where
 274     lower (x:xs) = toLower x : xs
 275     lower [] = []
 276     upper (x:xs) = toUpper x : xs
 277     upper [] = []
 278
 279 checkDef :: [SDef] -> [Def] -> Q ()
 280 checkDef x y =
 281     go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y)
 282   where
 283     go _ [] = return ()
 284     go [] (b:_) = error $ "Extra message constructor: " ++ constr b
 285     go (a:as) (b:bs)
 286         | sconstr a < constr b = go as (b:bs)
 287         | sconstr a > constr b = error $ "Extra message constructor: " ++ constr b
 288         | otherwise = do
 289             go' (svars a) (vars b)
 290             go as bs
 291     go' ((an, at):as) ((bn, mbt):bs)
 292         | an /= bn = error "Mismatched variable names"
 293         | otherwise =
 294             case mbt of
 295                 Nothing -> go' as bs
 296                 Just bt
 297                     | at == bt -> go' as bs
 298                     | otherwise -> error "Mismatched variable types"
 299     go' [] [] = return ()
 300     go' _ _ = error "Mistmached variable count"
 301
 302 toSDefs :: [Def] -> Q [SDef]
 303 toSDefs = mapM toSDef
 304
 305 toSDef :: Def -> Q SDef
 306 toSDef d = do
 307     vars' <- mapM go $ vars d
 308     return $ SDef (constr d) vars' (content d)
 309   where
 310     go (a, Just b) = return (a, b)
 311     go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a)
 312
 313 data SDef = SDef
 314     { sconstr :: String
 315     , svars :: [(String, String)]
 316     , scontent :: [Content]
 317     }
 318
 319 data Def = Def
 320     { constr :: String
 321     , vars :: [(String, Maybe String)]
 322     , content :: [Content]
 323     }
 324
 325 (</>) :: FilePath -> FilePath -> FilePath
 326 path </> file = path ++ '/' : file
 327
 328 loadLang :: FilePath -> FilePath -> IO (Maybe ([FilePath], (Lang, [Def])))
 329 loadLang folder file = do
 330     let file' = folder </> file
 331     isFile <- doesFileExist file'
 332     if isFile && ".msg" `isSuffixOf` file
 333         then do
 334             let lang = pack $ reverse $ drop 4 $ reverse file
 335             defs <- loadLangFile file'
 336             return $ Just ([file'], (lang, defs))
 337         else do
 338             isDir <- doesDirectoryExist file'
 339             if isDir
 340                 then do
 341                     let lang = pack file
 342                     (files, defs) <- unzip <$> loadLangDir file'
 343                     return $ Just (files, (lang, concat defs))
 344                 else
 345                     return Nothing
 346
 347 loadLangDir :: FilePath -> IO [(FilePath, [Def])]
 348 loadLangDir folder = do
 349     paths <- map (folder </>) . filter (`notElem` [".", ".."]) <$> getDirectoryContents folder
 350     files <- filterM doesFileExist paths
 351     dirs  <- filterM doesDirectoryExist paths
 352     langFiles <-
 353         forM files $ \file -> do
 354             if ".msg" `isSuffixOf` file
 355                 then do
 356                   defs <- loadLangFile file
 357                   return $ Just (file, defs)
 358                 else do
 359                   return Nothing
 360     langDirs <- mapM loadLangDir dirs
 361     return $ catMaybes langFiles ++ concat langDirs
 362
 363 loadLangFile :: FilePath -> IO [Def]
 364 loadLangFile file = do
 365     bs <- S.readFile file
 366     let s = unpack $ decodeUtf8 bs
 367     defs <- fmap catMaybes $ mapM (parseDef . T.unpack . T.strip . T.pack) $ lines s
 368     return defs
 369
 370 parseDef :: String -> IO (Maybe Def)
 371 parseDef "" = return Nothing
 372 parseDef ('#':_) = return Nothing
 373 parseDef s =
 374     case end of
 375         ':':end' -> do
 376             content' <- fmap compress $ parseContent $ dropWhile isSpace end'
 377             case words begin of
 378                 [] -> error $ "Missing constructor: " ++ s
 379                 (w:ws) -> return $ Just Def
 380                             { constr = w
 381                             , vars = map parseVar ws
 382                             , content = content'
 383                             }
 384         _ -> error $ "Missing colon: " ++ s
 385   where
 386     (begin, end) = break (== ':') s
 387
 388 data Content = Var Deref | Raw String
 389
 390 compress :: [Content] -> [Content]
 391 compress [] = []
 392 compress (Raw a:Raw b:rest) = compress $ Raw (a ++ b) : rest
 393 compress (x:y) = x : compress y
 394
 395 parseContent :: String -> IO [Content]
 396 parseContent s =
 397     either (error . show) return $ parse go s s
 398   where
 399     go = do
 400         x <- many go'
 401         eof
 402         return x
 403     go' = (Raw `fmap` many1 (noneOf "#")) <|> (fmap (either Raw Var) parseHash)
 404
 405 parseVar :: String -> (String, Maybe String)
 406 parseVar s =
 407     case break (== '@') s of
 408         (x, '@':y) -> (x, Just y)
 409         _ -> (s, Nothing)
 410
 411 data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg
 412
 413 instance IsString (SomeMessage master) where
 414     fromString = SomeMessage . T.pack
 415
 416 instance master ~ master' => RenderMessage master (SomeMessage master') where
 417     renderMessage a b (SomeMessage msg) = renderMessage a b msg